home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / mpfeel.lha / MPFeel / Modules / elopt.em < prev    next >
Lisp/Scheme  |  1992-10-06  |  11KB  |  314 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;                                                                           ;;
  3. ;;  EuLisp Module                     Copyright (C) University of Bath 1991  ;;
  4. ;;                                                                           ;;
  5. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  6.  
  7. ; $Id:$
  8. ;
  9. ; $Log:$
  10. ; 
  11.  
  12. (defmodule elopt
  13.  
  14.   (standard
  15.    loops
  16.    trandecl
  17.    tranutil) ()
  18.  
  19.   (deflocal ModuleName)
  20.   (deflocal bblist)
  21.   (deflocal endsbb-table (make-table))
  22.   (deflocal instr-type-table (make-table))
  23.   (deflocal opt-code-stream)
  24.   (deflocal label-tab)
  25.   (deflocal def-use-table)
  26.  
  27.   (defstruct opt-basic-block ()
  28.     (
  29.      ;; first-ins is the list on instructions which make up the basic block
  30.      ;; last-ins is the last instruction in the basic block
  31.      ;; next-blk is a list of basic blocks which may follow this one (max 2)
  32.      ;; prev-blk is a list of basic block which may preceed this one
  33.      (first-ins initform nil initarg first-ins accessor first-ins)
  34.      (last-ins initform nil initarg last-ins accessor last-ins)
  35.      (next-blk initform nil initarg next-blk accessor next-blk)
  36.      (prev-blk initform nil initarg prev-blk accessor prev-blk)
  37.      (gen initform nil initarg gen accessor gen)
  38.      (kill initform nil initarg kill accessor kill)
  39.      )
  40.     constructor make-opt-basic-block)
  41.   
  42.   (defmethod generic-prin ((x opt-basic-block) s)
  43.     (format s "#<opt-basic-block:~u~%" x)
  44.     (format s "~tfirst: ~a last:~a~%" (first-ins x) (last-ins x))
  45.     (for (setq i (next-blk x)) i (setq i (cdr i))
  46.      (format s "~t~tnext ~u" (car i)))
  47.     (format s "~%")
  48.     (for (setq i (prev-blk x)) i (setq i (cdr i))
  49.      (format s "~t~tprev ~u" (car i)))
  50.     (format s "~%gen:  ~a~%" (gen x))
  51.     (format s "kill: ~a>~%" (kill x)))
  52.  
  53.   (defmethod generic-write ((x opt-basic-block) s)
  54.     (format s "#<opt-basic-block:~u~%" x)
  55.     (format s "~tfirst: ~a last:~a~%" (first-ins x) (last-ins x))
  56.     (for (setq i (next-blk x)) i (setq i (cdr i))
  57.      (format s "~t~tnext ~u" (car i)))
  58.     (format s "~%")
  59.     (for (setq i (prev-blk x)) i (setq i (cdr i))
  60.      (format s "~t~tprev ~u" (car i)))
  61.     (format s "~%gen:  ~a~%" (gen x))
  62.     (format s "kill: ~a>~%" (kill x)))
  63.     
  64.  
  65.   (defcondition elopt-error ())
  66.  
  67.   (defun fourth (x) (car (cdr (cdr (cdr x)))))
  68.   (defun third (x) (car (cdr (cdr x))))
  69.   (defun second (x) (cadr x))
  70.   (defun first (x) (car x))
  71.  
  72.   (defun table-ref-or-bust (table slot)
  73.     (let ((x (table-ref table slot)))
  74.       (if x x
  75.     (error "table-ref-or-bust failed to find a value" elopt-error))))
  76.   
  77.   (defun optimise (a)
  78.     (opt-aux (copy-list a)))
  79.   
  80.   (defun opt-aux (a)
  81.     (let ((args (code-list a)))
  82.       (if (eq (caar args) 'entry)
  83.           (opt-entry a)
  84.       (error "Does not look like a command" elopt-error))
  85.       (mapc opt-aux (enclosed-blocks a))))
  86.  
  87. ;;; OK, given something which looks like
  88. ;;; ((entry name nargs results) (load...) (store...) (...) (...) (...))
  89. ;;; we split it up into a list of basic blocks                    
  90.   (defun opt-entry1 (block)
  91.     (cond ((null block) nil)
  92.       ((table-ref endsbb-table (caar block))
  93.        (let* ((temp (cdr block))    ; hold the list after the cut
  94.           (current-bb (make-opt-basic-block 'first-ins temp)))
  95.          (setf (last-ins (car bblist)) (car block))
  96.          (setq bblist (cons current-bb bblist))
  97.          ((setter cdr) block nil)    ; cut it
  98.          (opt-entry1 temp)))    ; cdr down the rest of the list
  99.       ((and (not (null (cdr block))) ; A label starts a block
  100.         (eq (caadr block) 'label))
  101.        (let* ((temp (cdr block))    ; hold the list after the cut
  102.           (current-bb (make-opt-basic-block 'first-ins temp)))
  103.          (setf (last-ins (car bblist)) (car block))
  104.          (setq bblist (cons current-bb bblist))
  105.          ((setter cdr) block nil)    ; cut it
  106.          (opt-entry1 temp)))
  107.       (t (opt-entry1 (cdr block)))))
  108.  
  109.   (defun opt-entry (block1)
  110.     (let ((current-bb (make-opt-basic-block 'first-ins block1)))
  111.       (setq bblist (cons current-bb nil))
  112.       (setq use-def-table (make-table))
  113.       (opt-entry1 block1)
  114. ;; Fix up last block - it might be null if last instruction is a null,
  115. ;; otherwise it needs to have last-ins set
  116.       (if (null (first-ins (car bblist)))
  117.       (setq bblist (cdr bblist))
  118.     (setf (last-ins (car bblist))
  119.           (car (last-pair (first-ins (car bblist))))))
  120. ;; bblist is now a reversed list of basic blocks
  121.       (setq bblist (reverse bblist))
  122. ;; set up the tempory table which joins labels to basic blocks
  123.       (setuplabeltable)
  124. ;; now fix up the pointers which link the basic blocks
  125.       (fixlinks)
  126.       (setup-def-use bblist)
  127.       (format t "~a~%" bblist)))
  128.  
  129.   (defun setup-def-use (bblist)
  130.     (if (null bblist) nil
  131.       (progn
  132.     (setup-genkill1 (car bblist))
  133.     (setup-def-use (cdr bblist)))))
  134.   
  135.   (defun setuplabeltable ()
  136.     (setq label-tab (make-table))
  137.     (add-ent bblist))
  138.  
  139.   (defun add-ent1 (x bblock)            ;x is a list of instructions
  140.     (if (eq (caar x) 'label)
  141.     ((setter table-ref) label-tab (cadar x) bblock)
  142.       nil))
  143.  
  144.   (defun add-ent (bbl)
  145.     (if (null bbl) nil
  146.       (progn
  147.     (add-ent1 (first-ins (car bbl)) (car bbl))
  148.     (add-ent (cdr bbl)))))
  149.  
  150.   (defun fixlinks ()
  151.     (fixlinks1 bblist)
  152.     (fixlinks2 bblist))
  153.  
  154.   ;; Given bblist, a list of basic blocks, we construct the list of
  155.   ;; following blocks. The first part is trivial, as we only need
  156.   ;; to add the next bblock on
  157.   (defun fixlinks1 (bbl)
  158.     (if (null bbl) nil
  159.       (let* ((ins (last-ins (car bbl)))
  160.         (endtype (table-ref endsbb-table (car ins))))        
  161.     ;; The trivial part - join to next blockf unless it is a jump
  162.     (if (or (null (cdr bbl)) (eq (car ins) 'jump)) nil
  163.       ((setter next-blk) (car bbl) (cons (cadr bbl) (next-blk (car bbl)))))
  164.     ;; The slightly less trivial bit - join to other blocks
  165.     (if (eq endtype 'ajump)
  166.         ((setter next-blk) (car bbl)
  167.           (cons (table-ref-or-bust label-tab
  168.                        (if (eq (car ins) 'jump)
  169.                            (cadr ins)
  170.                          (fourth ins)))
  171.             (next-blk (car bbl))))
  172.         nil)
  173.     (fixlinks1 (cdr bbl)))))
  174.  
  175.   ;; set up the back pointers
  176.   (defun fixlinks2 (bbl)
  177.     (if (null bbl) nil
  178.       (progn
  179.     (for (setq i (next-blk (car bbl))) (not (null i)) (setq i (cdr i))
  180.          ((setter prev-blk) (car i) (cons (car bbl) (prev-blk (car i)))))
  181.     (fixlinks2 (cdr bbl)))))
  182.  
  183.   (defun setup-def-use-table (bbl)
  184.     (if (null bbl) nil
  185.       (progn
  186.     (setup1-def-use-table (first-ins (car bbl)))
  187.     (setup-def-use-table (cdr bbl)))))
  188.  
  189.   ;; Setup the list of registers which are generated and killed
  190.   ;; by this basic block
  191.   (defun setup-genkill1 (bb)
  192.     (let ((gk (genkill (cons nil nil) (first-ins bb))))
  193.       (setf (gen bb) (car gk))
  194.       (setf (kill bb) (cdr gk))))
  195.  
  196.   ;; return a cons cell. CAR is a list of 'gen' registers, CDR is a list
  197.   ;; of 'killed' registers, insl is an instruction list
  198.   (defun genkill (res insl)
  199.     (if (null insl) res
  200.       (let ((command (caar insl))    ;Elvira Instruction
  201.         (args (cdar insl))        ;Its arguements
  202.         (genl (car res))        ;Generated definitions
  203.         (killl (cdr res)))        ;Killed definitions
  204.     (cond
  205.      ((eq command 'alloca))        ;takes a number
  206.      ((eq command 'apply)        ;o1=apply(i1,i2)
  207.       (setq killl (addmember killl (car args)))
  208.       (setq killl (addmember killl (cadr args)))
  209.       (setq genl (addmember genl 'o1)))
  210.      ((eq command 'begin-let/cc))    ;no parameters
  211.      ((eq command 'begin-unwind-protect)
  212.       (setq killl (addmember killl (car args))))
  213.      ((eq command 'begin-with-handler)
  214.       (setq killl (addmember killl (car args))))
  215.      ((eq command 'bind))        ;need to think about this one
  216.      ((eq command 'dealloca))    ;takes a number
  217.      ((eq command 'entry))        ;Should use the initial regs
  218.      ((eq command 'end-let/cc))    ;no parameters
  219.      ((eq command 'end-unwind-protect)) ;no parameters
  220.      ((eq command 'end-with-handler)) ;no parameters
  221.      ((eq command 'function))    ;module,name,num-args
  222.      ((eq command 'jump))        ;label
  223.      ((eq command 'jumpeq)        ;reg reg label. 2nd reg can be 'nil
  224.       (setq killl (addmember killl (car args)))
  225.       (setq killl (addmember killl (cadr args))))
  226.      ((eq command 'return)
  227.       (setq killl (addmember killl 'o1))) ;need to think about this one
  228.      ((eq command 'unbind))
  229.      ((eq command 'cons)
  230.       (setq killl (addmember killl (cadr args)))
  231.       (setq killl (addmember killl (caddr args)))
  232.       (setq genl (addmember genl (car args))))
  233.      ((eq command 'gctrap))        ;does not effect usage
  234.      ((eq command 'label))        ;does not effect usage
  235.      ((eq command 'link)
  236.        (cond
  237.          ((eq (car args) 'self) nil)
  238.          ((symbolp (car args)) (break))
  239.          ((eq (caar args) 'local)
  240.            (setq killl (killmultiple killl (cadr args)))
  241.            (setq genl (addmember genl 'o1)))
  242.          ((eq (caar args) 'nonlocal)
  243.            (setq killl (killmultiple killl (cadr args)))
  244.            (setq genl (addmember genl 'o1)))
  245.          ((eq (caar args) 'display))
  246.          (t (error "Unknown link" el2c-error))))
  247.      ((eq command 'load)
  248.        (setq genl (addmember genl (car args)))
  249.        (setq killl (addopand killl (cadr args))))
  250.      ((eq command 'store)
  251.        (setq killl (addmember killl (car args)))
  252.        (setq genl (addopand genl (cadr args))))
  253.      (t (format t "UNKNOWN(~a ~a);~%" command args)))
  254.     ; cdr down the list
  255.     (genkill (cons genl killl) (cdr insl))
  256.     )))
  257.   
  258.   (defun addopand (l opand)
  259.     l)
  260.  
  261.   (defun addmember (list newmem)
  262.     (if (memq newmem list) list (cons newmem list)))
  263.   
  264.   (defun killmultiple (list number)
  265.     (killmultiple1 list number '(i1 i2 i3 i4 i5 i6 i7 i8 i9)))
  266.   
  267.   (defun killmultiple1 (list number regs)
  268.     (if (zerop number) list
  269.       (killmultiple1 (addmember list (car regs)) (binary-minus number 1)
  270.              (cdr regs))))
  271.  
  272.     ;; insl is a list of instructions
  273.   (defun setup1-def-use-table (insl)
  274.     (if (null insl) nil
  275.       (progn
  276.     (setup2-def-use-table (car insl) (cdar insl))
  277.     (setup1-def-use-table (cdr insl)))))
  278.  
  279.   (defun setup2-def-use-table (ins opands)
  280.     (if (null opands) nil
  281.       (progn
  282.     (if (atom (car opands))
  283.         ((setter table-ref) use-def-table (car opands)
  284.          (cons ins (table-ref use-def-table (car opands))))
  285.       (error (format nil "!Atom in setup2-def-use-table ~a~%" elopt-error)))
  286.     (setup2-def-use-table ins (cdr opands)))))
  287.   
  288.   (defun init-bbs-table ()
  289.     ((setter table-ref) endsbb-table 'jump 'ajump)
  290.     ((setter table-ref) endsbb-table 'jumpeq 'ajump)
  291.     ((setter table-ref) endsbb-table 'jumpne 'ajump)
  292.     ((setter table-ref) endsbb-table 'jumpgt 'ajump)
  293.     ((setter table-ref) endsbb-table 'jumpgeq 'ajump)
  294.     ((setter table-ref) endsbb-table 'jumple 'ajump)
  295.     ((setter table-ref) endsbb-table 'jumpleq 'ajump)
  296.     ((setter table-ref) endsbb-table 'entry t)
  297.     )
  298.  
  299.   (init-bbs-table)
  300.   (setq fred '((entry fred)
  301.            (load o1 1)
  302.            (label 5)
  303.            (store o1 (display 1 2))
  304.            (jumpeq l1 nil 6)
  305.            (cons l1 i1 i2)
  306.            (load o1 4)
  307.            (label 6)
  308.            ))
  309.   (defun try-it ()
  310.     (opt-entry (copy fred)))
  311.   
  312.   (export optimise opt-code-stream)
  313. )
  314.